#!/usr/bin/perl -wT

# rcsweb.pl

# A web interface to pl.

# This program should be run under a setuid wrapper,
# which sets the effective userid to the user
# in the environment variable REMOTE_USER.

package Rcsweb;
use CGI;
use strict;
use IO::File;
use IO::Dir;
use POSIX qw(strftime);
use Rcs;

use constant RCSSUFFIX => ',v';
use constant RCSDIR => 'RCS';
use constant RCSBINDIR => '/usr/bin';
use constant AUTOCONVERT => 1;  # automatically convert dos to unix files
use constant MAXLINES => 35;  # most rows in an input box for editting a file

$Rcsweb::VERSION=0.07;

# directories that are accessible
$Rcsweb::rootdirs = [
    IO::File->new('<./shared-dirs')->getlines()
    ];

$ENV{'PATH'} = '';

&main;

#
# html_quote
#
# escape a string for use in html
#
sub html_quote {
    my ($var) = @_;
    $var =~ s/&/\&amp\;/g;
    $var =~ s/</\&lt\;/g;
    $var =~ s/>/\&gt\;/g;
    return $var;
}

sub max { my ($a,$b) = @_; return ($a > $b ? $a : $b); }
sub min { my ($a,$b) = @_; return ($a < $b ? $a : $b); }

#
# is_rcs_dir
#
# returns undef unless the dir has a valid RCS subdirectory
#
sub is_rcs_dir {
    my ($d) = @_;
    if ( -w $d && -w $d."/".RCSDIR ) { return $d; }
    return undef;
}

#
# is_rcs_file
#
# returns undef unless this file has been initialized
#

sub is_rcs_file {
    my ($d,$f) = @_;
    if (-f $d."/".$f && -f $d.'/'.RCSDIR.'/'.$f.RCSSUFFIX && $f !~ m|/|) { return $f; }
    return undef;
}

#
# is_potential_rcs_file
#
# returns undef unless the user could add this file to the repository
#
sub is_potential_rcs_file {
    my ($d,$f) = @_;
    if (-f $d."/".$f && !(-f $d.'/'.RCSDIR.'/'.$f.RCSSUFFIX) && $f !~ m|/| && is_rcs_dir($d)) { 
        return $f; 
    }
    return undef;
}

#
# validate_cwd_and_filename
#
# untaint, validate cwd and filename, and return them.
#
sub validate_cwd_and_filename {
    my ($cwd,$filename) = @_;
    
    return undef unless is_rcs_dir($cwd);
    if ($cwd =~ /^(.*)$/) { $cwd = $1; } # untaint 
    return undef unless is_rcs_file($cwd,$filename);
    if ($filename =~ /^(.*)$/) { $filename = $1; } # untaint
    
    return ($cwd,$filename);
}


#
# rcs_setup
#
# Create and setup an Rcs object.
#

sub rcs_setup {
    my ($filename, $cwd) = @_;
    my $rcs = new Rcs;

    ($cwd,$filename) = validate_cwd_and_filename($cwd,$filename);
    return undef unless (defined($filename) && defined($cwd));

    $rcs->workdir($cwd);
    $rcs->bindir(RCSBINDIR);
    $rcs->arcext(RCSSUFFIX);
    $rcs->rcsdir($cwd."/".RCSDIR);
    $rcs->file("$filename");
    return $rcs;
}

# co_lock
#
# Check out and lock a file.
#
sub co_lock {
    my $q = shift;
    
    my $rcs = rcs_setup($q->param("filename"),$q->param("cwd")) || return $q->p("co_lock error");

    return $q->p("This file is already locked.") if $rcs->lock;

    $rcs->co('-l');
    return $q->p("Locked ".$q->param("filename"));
}

# rlog
#
# Display the revision history for a file.
#
sub rlog {
    my $q = shift;
    my $rcs = rcs_setup($q->param("filename"),$q->param("cwd")) || return $q->p("rlog error");

    print $q->pre(join '', map { html_quote($_); } $rcs->rlog);
    return undef;
}

#
# convert_dos_to_unix
#
# convert a file from dos to unix format.
# returns an error message on failure, undef on success.
#
sub convert_dos_to_unix {
    my ($cwd,$filename) = @_;
    return unless (AUTOCONVERT);

    my @lines = IO::File->new("<$cwd/$filename")->getlines();
    if ($lines[0] =~ /\r\n/) {
       my $fh = new IO::File "> $cwd/$filename";
       return "<p>error converting carriage returns of $cwd/$filename</p>" unless defined($fh);
       foreach my $l (@lines) {
                $l =~ s/\r$//;
                print $fh $l;
            }
       $fh->close;
    }
    return undef;
}


#
# init_rcs_file
#
# Add a file to the repository
#
sub init_rcs_file {
    my $q = shift;
    my ($cwd,$filename) = map { $q->param($_) } qw(cwd filename);
    my $convertmsg = '';

    return $q->p("Can't initialize $cwd/$filename") unless is_potential_rcs_file($cwd,$filename);

    # untaint
    if ($cwd =~ /^(.*)$/) { $cwd = $1; } 
    if ($filename =~ /^([^\/]*)$/) { $filename = $1; } else { return $q->p("bad filename"); }

    # Convert dos files to unix files 
    my $errmsg = convert_dos_to_unix($cwd,$filename);
    return($errmsg) if defined($errmsg);

    # Make a new object.
    my $rcs = new Rcs || return $q->p("error trying to initialize $filename");
    $rcs->workdir($cwd);
    $rcs->bindir(RCSBINDIR);
    $rcs->arcext(RCSSUFFIX);
    $rcs->rcsdir($cwd."/".RCSDIR);
    $rcs->file("$filename");

    if (!defined($q->param("goahead"))) {
        print $q->h1({align=>"center"}, "Initializing $filename");
        print $q->p("Please enter a description of this file.");
        print "<form method=POST>",$q->textarea(-name=>"initcomment",-rows=>4,-columns=>50);
        print $q->br,$q->submit(name=>"Initialize",value=>"Initialize");
        print $q->hidden("goahead",1);
        print map { $q->hidden($_,$q->param($_)) } qw(filename cwd option);
        print "</form>";
        return undef;
    }

    my @params = ('-i');
    if (my $msg = $q->param("initcomment")) {
        push @params, "-t-$msg";
    }

    $rcs->rcs(@params);
    $rcs->ci("-u");
    return $q->p("Initialized $filename $convertmsg");
}

#
# ci_unlock
#
# Check in and unlock a file
#
# Any returned value will be output.
#
sub ci_unlock {
    my $q = shift;
    my ($cwd,$filename) = map { $q->param($_) } qw(cwd filename);
    my $rcs = rcs_setup($filename,$cwd) || return $q->p("ci_unlock error");

    return $q->p("This file is not locked by you.") unless $rcs->lock eq $ENV{'REMOTE_USER'};

    # Convert dos files to unix files
    ($cwd,$filename) = validate_cwd_and_filename($cwd,$filename); # untaint
    my $errmsg = convert_dos_to_unix($cwd,$filename);
    return($errmsg) if defined($errmsg);
    my $changed = $rcs->rcsdiff;

    if ($changed && !defined($q->param("goahead"))) {
        print $q->h1({align=>"center"}, "Checking in $filename");
        print $q->p("Please enter a comment, explaining your changes:");
        print "<form method=POST>",$q->textarea(-name=>"logcomment",-rows=>4,-columns=>50);
        print $q->br,$q->submit(name=>"Check in",value=>"Check in");
        print $q->hidden("goahead",1);
        print map { $q->hidden($_,$q->param($_)) } qw(filename cwd option);
        print "</form>";
        print $q->hr;
        print $q->p("Changes since last version:");
        my @changes = map { html_quote($_); } $rcs->rcsdiff;
        print $q->pre( join "",@changes );
        exit 0;
    }

    my @params = ('-u');
    if (my $logmsg = $q->param("logcomment")) {
        push @params, "-m$logmsg";
    }

    $rcs->ci(@params); 
    return $q->p("Unlocked $filename");
}

#
# present_form
#
# Presents a list of directories and files, and options
#

sub present_form {
    my ($q,$cwd) = @_;
    my %thisdir;
    my $dirs;
    my $scriptname = $ENV{'SCRIPT_NAME'};
    my $user = $ENV{'REMOTE_USER'};
    my $rootdirs = $Rcsweb::rootdirs;

    #
    # Get list of directories
    #
    $cwd ||= '';
    if (length($cwd)) {
        die "Not an absolute path: $cwd" unless $cwd =~ /^\//;
        tie %thisdir, "IO::Dir", $cwd || die "couldn't open $cwd";
        $dirs = [ grep { $_ ne '.' && $_ ne 'RCS' && -d $cwd."/".$_ && is_rcs_dir($cwd.'/'.$_) } keys %thisdir ];
        if ( !is_rcs_dir($cwd) ) {
            print "Invalid directory: $cwd.\n";
            return;
        }
     } else {
        $dirs = $rootdirs;
    }

    print $q->h1({-align=>"center"}, $cwd) if length($cwd);

    #
    # Print the list of directories
    # 
    if (scalar(@$dirs) > 0) {
        print "<table>";
        print "<tr><th>Directories</th></tr>\n";
        foreach my $i (@$dirs) {
            print "<tr>";
            if ($i eq '..') {
                if ($cwd =~ m|(.*)/(^/)*|) {
                    print "<td><a href=$scriptname?cwd=$1>(up)</td>\n";
                }
            } else {
                print "<td><a href=$scriptname?cwd=$cwd".(length($cwd)?'/':'')."$i>$i</td>\n";
            }
            print "</tr>";
        }
        print "</table>\n";
    }

    return unless length($cwd); # intro page

    my $rcsfiles = [ grep { is_rcs_file($cwd,$_) } keys %thisdir ];
    my $nonrcsfiles = [ grep { is_potential_rcs_file($cwd,$_) } keys %thisdir ];
    
    if (scalar(@$rcsfiles)==0) {
        print "<p>no rcs files in this directory</p>";
    }

    if (scalar(@$rcsfiles) > 0) {
        print "<table border=1>\n";
        print "<tr>";
        print "<th>Filename</th><th>Locker</th><th>Last author</th><th>Head Revision (date)</th><th colspan=3>Options</th>\n"; print "</tr>";
        foreach my $i (@$rcsfiles) {
            print "<tr>";
            my $hiddenfileinfo = "<input type=hidden name=cwd value=\"$cwd\">".
                      "<input type=hidden name=filename value=\"$i\">";

            my $rcs = Rcs->new();
            $rcs->bindir(RCSBINDIR);
            $rcs->workdir($cwd);
            $rcs->arcext(RCSSUFFIX);
            $rcs->rcsdir($cwd."/".RCSDIR);
            $rcs->file($i);
            
            
            my $revdate = $rcs->revdate;
            my $lock = $rcs->lock || '';
            if (defined($revdate)) {
                $revdate    = strftime("%a, %b %e, %Y",$rcs->revdate);
                print "<td>$i</td><td>".$lock."</td><td>".$rcs->author.
                      "</td><td>".$rcs->head." ($revdate) </td>\n";
            } else { # No revisions yet; it was just initialized
                print "<td>$i</td><td>&nbsp;</td><td>&nbsp;</td><td>(no revisions yet)</td>\n";
            }

            # print options for this file

            # Some common stuff:
            my $scriptname = $ENV{'SCRIPT_NAME'};
            my $logoption = "<td><a href=$scriptname?option=rlog&".
                "cwd=$cwd&filename=$i>View log</a></td>\n";
            # Cases: (1) the remote user has locked the file,
            #   (2) someone else has locked the file, (3) the file is unlocked.
            #   (4) the file isn't in the repository

            if ($lock eq $user) {
                print "<td><form action=\"$scriptname\" method=POST>".$hiddenfileinfo;
                print "<input type=hidden name=option value=ci_unlock>".
                      "<input type=submit name=\"Check in/unlock\" value=\"Check in/unlock\">";
                print "</form></td>\n";
                print $logoption;
                print "<td><a href=$scriptname?option=edit&cwd=$cwd&filename=$i>Edit</a></td>\n";
            } elsif ($rcs->lock) {
                print "<td>&nbsp</td>";
                print $logoption;
                print "<td>&nbsp</td>";
            } else {
                print "<td><form action=\"$scriptname\" method=POST>".$hiddenfileinfo;
                print "<input type=hidden name=option value=co_lock>".
                      "<input type=submit name=\"lock\" value=\"lock\">";
                print "</form></td>\n";
                print $logoption;
                print "<td>&nbsp</td>";
            }
            print "</tr>";
        } 
        print "</table>";
    }

    return unless scalar(@$nonrcsfiles) > 0;

    print "<table>";
    print "<br>";
    print "<th>Non-rcs files</th>\n";
    foreach my $i ( @$nonrcsfiles ) {
        if (is_potential_rcs_file($cwd,$i)) {
            print "<tr>";
            print "<td>$i</td>\n";
            my $hiddenfileinfo = "<input type=hidden name=cwd value=\"$cwd\">".
                  "<input type=hidden name=filename value=\"$i\">";
            print "<td><form action=\"$scriptname\" method=POST>".$hiddenfileinfo;
            print "<input type=hidden name=\"option\" value=\"initialize\">".
                  "<input type=submit name=\"initialize\" value=\"initialize\">";
            print "</form></td>\n";
            print "</tr>";
         }
    }

}

#
# print_header
#
# prints the header for each page
#
sub print_header {
    my ($q,$user) = @_;
    my $v = $Rcsweb::VERSION;

    print $q->header;
    print "<table width=100% align=right bgcolor=blue cellspacing=0 cellpadding=0 border=0>";
    print "<tr><td align=left><font color=white>rcsweb v$v</font></td>".
          "<td align=right><font color=white>$user</font></td></tr>";
    print "</table><br><br>";
}

#
# edit_file
#
# present the file in an input box for editting,
# and allow a file upload too (TODO)
#
sub edit_file {
    my ($q) = @_;
    my ($cwd,$filename) = map { $q->param($_) } qw(cwd filename);
    my $rcs = rcs_setup($filename,$cwd) || return $q->p("edit error");

    if (defined($q->param("Back"))) { return $q->p("Save aborted"); }

    if (!defined($q->param("Save"))) {
        # Present the form

        print $q->h1($filename), $q->p("(in $cwd)"), $q->hr;
        my @lines = IO::File->new("<$cwd/$filename")->getlines();
        print "<form method=post>";
        print $q->textarea(
            -name => "filedata",
            -rows => min(scalar(@lines) + 10,MAXLINES), 
            -default=>(join '',@lines),
            -columns => 100);
        print $q->hr;
        print $q->hidden( -name => "cwd", -value => $cwd),
            $q->hidden( -name => "filename", -value => $filename),
            $q->hidden( -name => "option", -value => "edit"),
            $q->submit( -name => "Save", value=>"Save"),
            $q->submit( -name => "Back", value=>"Abort Changes/Go Back");
        print "</form>";
    } else { 
        # Save the file
        ($cwd,$filename) = validate_cwd_and_filename($cwd,$filename); # untaint
        my $fh = new IO::File "> $cwd/$filename";
        return $q->p("error opening $cwd/$filename for writing") unless defined($fh);
        print $fh $q->param("filedata");
        $fh->close;

        return $q->p("Saved $filename");
    }

    return undef;
}


#
# main
#

sub main {
    my $q = new CGI;
    my $cwd;

    my $user = $ENV{'REMOTE_USER'};
    if (!defined($user)) {
        print $q->p("Configuration error -- no remote user.");
        exit 1;
    }
    print_header($q,$user);

    if ($q->param()) {
        $cwd = $q->param("cwd");
        my $option=$q->param("option") || '';
        if ($option eq "co_lock") {
            print co_lock($q);
            present_form($q,$cwd);
        } elsif ($option eq "ci_unlock") {
            print ci_unlock($q);
            present_form($q,$cwd);
        } elsif ($option eq "rlog") {
            print rlog($q) || '';
        } elsif ($option eq "edit") {
            if (my $out=edit_file($q)) {
                print $out;
                present_form($q,$cwd);
            }
        } elsif ($option eq "initialize") {
            if (my $msg = init_rcs_file($q)) {
                print $msg;
                present_form($q,$cwd);
            }
        } else { 
            present_form($q,$cwd);
        }
    } else {
        present_form($q,$cwd);
    }
}

